home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / picture-files.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  14.0 KB  |  386 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;picture-files.lisp
  4. ;;copyright © 1990, Apple Computer, Inc.
  5.  
  6. ; Examples of reading and writing picture files.
  7. ; Adapted from the code on page V-88 of Inside Macintosh.
  8. ; If you draw a PICT2 pict to a color window with a palette
  9. ; (e.g. a PALETTE-WINDOW below), it will copy the color table
  10. ; to the palette.  Does not yet have any way to clean up your
  11. ; desktop.  You can always close all the color windows, then
  12. ; zoom the listener to fill the screen and back.
  13.  
  14. ; See the function DISPLAY-PICT-FILE for an example of use.
  15.  
  16. ;;;;;;;
  17. ;;
  18. ;; Modification history
  19. ;;
  20. ;; 04/28/93 mwp Release
  21. ;; 04/17/92 bill Steve Miner's def-load-pointers for *std-bits-proc*
  22. ;; ------------- 2.0
  23. ;; 12/18/91 bill (from STEVE.M) remove %getport, it's in the kernel.
  24. ;;          scale-point -> scale-lisp-point so it won't conflict with
  25. ;;          ccl:library;quickdraw.lisp.;;               
  26. ;; 10/08/91 bill move to CCL package
  27. ;;
  28.  
  29. #-ccl-2
  30. (eval-when (:compile-toplevel :load-toplevel :execute)
  31.   (error "This code expects MCL 2.0 or later."))
  32.  
  33. (in-package :ccl)
  34.  
  35. (require :mac-file-io)              ; high-level File I/O ala Inside Macintosh
  36.  
  37. (eval-when (:compile-toplevel :load-toplevel :execute)
  38.   (export '(with-pict-input-file with-pict-output-file display-pict-file
  39.              palette-window)))
  40.  
  41. (defvar *pict-input-pb* nil)
  42.  
  43. (defpascal *get-pict-data* (:ptr dataPtr :word byteCount)
  44.   (FSRead *pict-input-pb* byteCount dataPtr 0 nil))
  45.  
  46. (defvar *pict-output-pb* nil)
  47. (defvar *pict-output-handle* nil)
  48.  
  49. (defpascal *put-pict-data* (:ptr dataPtr :word byteCount)
  50.   (FSWrite *pict-output-pb* byteCount dataPtr 0 nil)
  51.   (let ((handle *pict-output-handle*))
  52.     (when handle
  53.       (rset handle :picture.picsize 
  54.             (+ byteCount (rref handle :picture.picsize))))))
  55.  
  56. ; Color palette stuff.
  57. ; Note that this initial palette is all black.
  58. ; It really should be initialized to the default
  59. ; system color table for the device with the most bits.
  60. ; It works because set the palette from a PICT that is
  61. ; drawn here.
  62. (defun add-palette (window)
  63.   (when (window-color-p window)
  64.     (let ((wptr (wptr window)))
  65.       (when (%null-ptr-p (#_GetPalette wptr))
  66.         (#_SetPalette 
  67.          wptr
  68.          (#_NewPalette 256 (%null-ptr) 2 0 )
  69.          nil)))))
  70.  
  71. (defun remove-palette (window)
  72.   (when (window-color-p window)
  73.     (let* ((wptr (wptr window))
  74.            (palette (#_GetPalette wptr)))
  75.       (declare (dynamic-extent palette))
  76.       (unless (%null-ptr-p palette)
  77.         (#_SetPalette  wptr (%null-ptr) nil)
  78.         (#_DisposePalette palette)))))
  79.         
  80. (defclass palette-window (window) ()    ; a class for 8-bit graphics
  81.   (:default-initargs
  82.     :color-p t
  83.     :grow-icon-p nil))
  84.  
  85. (defmethod initialize-instance :after ((w palette-window) &key)
  86.   (add-palette w))
  87.  
  88. (defmethod window-close :before ((w palette-window))
  89.   (remove-palette w))
  90.  
  91.  
  92. (defvar *std-bits-proc* nil)
  93. (def-load-pointers *std-bits-proc* ()
  94.   (setq *std-bits-proc* (%int-to-ptr 0)))
  95.  
  96. (defvar *bits-proc-cnt* 0)
  97. (defvar *palette-changes* 0)
  98.  
  99. (defpascal *bits-proc* (:ptr srcBits :ptr srcRect :ptr dstRect
  100.                              :word mode :ptr rgnHandle)
  101.    (incf *bits-proc-cnt*)
  102.    (let* ((port (%getPort)))
  103.      (declare (dynamic-extent port))
  104.      (when (and (logbitp 15 (rref srcBits :pixMap.rowBytes :storage :pointer))
  105.                 (logbitp 15 (rref port :cGrafport.portVersion)))
  106.        (let ((palette (#_GetPalette port)))
  107.          (declare (dynamic-extent palette))
  108.          (unless (%null-ptr-p palette)
  109.            (incf *palette-changes*)
  110.            (#_CTab2Palette (rref srcBits :pixMap.pmTable :storage :pointer)
  111.                            palette
  112.                            2  #x0000)   ; tolerant usage, no tolerance
  113.            (#_ActivatePalette port)))))
  114.    (ff-call *std-bits-proc*
  115.                  :ptr srcBits :ptr srcRect :ptr dstRect :word mode :ptr rgnHandle))
  116.  
  117.  
  118.  
  119. (eval-when (:compile-toplevel :execute)
  120. (defrecord QDProcs
  121.   (textProc :pointer)
  122.   (lineProc :pointer)
  123.   (rectProc :pointer)
  124.   (rRectProc :pointer)
  125.   (ovalProc :pointer)
  126.   (arcProc :pointer)
  127.   (polyProc :pointer)
  128.   (rgnProc :pointer)
  129.   (bitsProc :pointer)
  130.   (commentProc :pointer)
  131.   (txMeasProc :pointer)
  132.   (getPicProc :pointer)
  133.   (putPicProc :pointer)
  134.   (opcodeProc :pointer)
  135.   (newProc1 :pointer)
  136.   (newProc2 :pointer)
  137.   (newProc3 :pointer)
  138.   (newProc4 :pointer)
  139.   (newProc5 :pointer)
  140.   (newProc6 :pointer))
  141.  
  142. (defconstant $CQDProcs-size (record-length :QDProcs))
  143. (defconstant $QDProcs-size (- $CQDProcs-size (* 7 4)))
  144. )
  145.  
  146. (defvar *pict-input-grafProcs* nil)
  147.  
  148. ; Offsets in the GrafProcs structure that we allocate for storing our state
  149. (defconstant $gpWptr 0)
  150. (defconstant $gpPictHand 4)
  151. (defconstant $gpOldGrafProcs 8)
  152. (defconstant $gpHeaderSize 12)
  153. (defconstant $pictureSize 10)            ; length of a PICTURE header
  154.  
  155. ; Returns a PICTURE handle on which you can call _DrawPicture to the window.
  156. ; If error, signal if errorp is true, or return two values, NIL and the
  157. ; error number.
  158. (defun open-pict-input-file (filename window &optional (errorp t))
  159.   (let ((old-pb *pict-input-pb*)
  160.         pb pict-hand errnum grafProcs)
  161.     (when old-pb
  162.       (error "A picture input file is already open"))
  163.     (unwind-protect
  164.       (progn
  165.         (setq *pict-input-pb* t)            ; grab it
  166.         (let* ((wptr (wptr window))
  167.                (color-p (window-color-p window))
  168.                (size (if color-p $CQDProcs-size $QDProcs-size)))
  169.           (setq grafProcs (#_NewPtr :errchk (+ $gpHeaderSize size)))
  170.           (setq pict-hand (#_NewHandle :errchk $pictureSize))
  171.           (multiple-value-setq (pb errnum) (FSOpen filename nil 0 errorp))
  172.           (if (not pb)
  173.             (values nil errnum)
  174.             (let ((oldGrafProcs (rref wptr :grafport.grafProcs))
  175.                   (newGrafProcs (%inc-ptr GrafProcs $gpHeaderSize)))
  176.               (declare (dynamic-extent oldGrafProcs newGrafProcs))
  177.               (%put-ptr grafProcs wptr $gpWptr)
  178.               (%put-ptr grafProcs pict-hand $gpPictHand)
  179.               (%put-ptr grafProcs oldGrafProcs $gpOldGrafProcs)
  180.               (if (%null-ptr-p oldGrafProcs)
  181.                 (if color-p
  182.                   (#_SetStdCProcs newGrafProcs)
  183.                   (#_SetStdProcs newGrafProcs))
  184.                 (#_BlockMove oldGrafProcs newGrafProcs size))
  185.               (setFpos pb 512)          ; skip MacDraw header block
  186.               (with-pointers ((pict pict-hand))
  187.                 (FSRead pb $pictureSize pict))   ; read size & picture frame
  188.               (rset newGrafProcs :QDProcs.getPicProc *get-pict-data*)
  189.               (when (window-color-p window)
  190.                 (let ((bitsProc (rref newGrafProcs :QDProcs.bitsProc)))
  191.                   (declare (dynamic-extent bitsProc))
  192.                   (unless (eql *bits-proc* bitsProc)
  193.                     (%setf-macptr *std-bits-proc* bitsProc)
  194.                     (rset newGrafProcs :QDProcs.bitsProc *bits-proc*))))
  195.               (setq *pict-input-GrafProcs* grafProcs
  196.                     *pict-input-pb* pb)
  197.               (rset wptr :grafport.grafProcs newGrafProcs)
  198.               pict-hand
  199.               ))))
  200.       (when (eq t *pict-input-pb*)
  201.         (if pb (FSClose pb))
  202.         (setq *pict-input-pb* nil)
  203.         (when grafProcs
  204.           (#_DisposePtr grafProcs))
  205.         (when pict-hand
  206.           (#_DisposeHandle pict-hand))))))
  207.  
  208. (defun close-pict-input-file (pict-hand)
  209.   (let ((grafProcs *pict-input-GrafProcs*)
  210.         (pb *pict-input-pb*))
  211.     (unless pb
  212.       (error "No picture input file open."))
  213.     (unless (eql pict-hand (%get-ptr grafProcs $gpPictHand))
  214.       (error "~s is not the pict-hand returned from open-pict-input-file"
  215.              pict-hand))
  216.     (let ((wptr (%get-ptr grafProcs $gpWptr))
  217.           (oldGrafProcs (%get-ptr grafProcs $gpOldGrafProcs)))
  218.       (rset wptr :grafport.GrafProcs oldGrafProcs)
  219.       (#_DisposePtr grafProcs)
  220.       (#_DisposeHandle pict-hand)
  221.       (FSClose pb)
  222.       (setq *pict-input-GrafProcs* nil
  223.             *pict-input-pb* nil))))
  224.  
  225. (defmacro with-pict-input-file ((pict-hand filename window) &body body)
  226.   `(let ((,pict-hand (open-pict-input-file ,filename ,window)))
  227.      (unwind-protect
  228.        (progn ,@body)
  229.        (close-pict-input-file ,pict-hand))))
  230.  
  231. (defvar *pict-output-GrafProcs* nil)
  232.  
  233. ; Picture output to a file.
  234. ; Sets up to output a picture to the file named filename.
  235. ; Picture output will be done on the given window in the picture
  236. ; frame described by the two points topleft & botright
  237. (defun open-pict-output-file (filename window topleft botright)
  238.   (let ((old-pb *pict-output-pb*)
  239.         pb pict-hand grafProcs)
  240.     (when old-pb
  241.       (error "A picture output file is already open"))
  242.     (unwind-protect
  243.       (progn
  244.         (setq *pict-output-pb* t)            ; grab it
  245.         (create-file filename)
  246.         (let* ((wptr (wptr window))
  247.                (color-p (window-color-p window))
  248.                (size (if color-p $CQDProcs-size $QDProcs-size)))
  249.           (setq grafProcs (#_NewPtr :errchk (+ $gpHeaderSize size)))
  250.           (setq pb (FSOpen filename t))
  251.           (let ((oldGrafProcs (rref wptr :grafport.grafProcs))
  252.                 (newGrafProcs (%inc-ptr GrafProcs $gpHeaderSize)))
  253.             (declare (dynamic-extent oldGrafProcs newGrafProcs))
  254.             (%put-ptr grafProcs wptr $gpWptr)
  255.             (%put-ptr grafProcs oldGrafProcs $gpOldGrafProcs)
  256.             (if (%null-ptr-p oldGrafProcs)
  257.               (if color-p
  258.                 (#_SetStdCProcs newGrafProcs)
  259.                 (#_SetStdProcs newGrafProcs))
  260.               (#_BlockMove oldGrafProcs newGrafProcs size))
  261.             (%stack-block ((data 4))
  262.               (%put-long data 0)
  263.               (dotimes (i (round (+ 512 $PictureSize) 4))
  264.                 (FsWrite pb 4 data)))
  265.             (rset newGrafProcs :QDProcs.putPicProc *put-pict-data*)
  266.             (unwind-protect
  267.               (progn
  268.                 (rset wptr :grafport.grafProcs newGrafProcs)
  269.                 (setq *pict-output-GrafProcs* t
  270.                       *pict-output-handle* pict-hand
  271.                       *pict-output-pb* pb)
  272.                 (rlet ((picFrame :rect :topleft topleft :bottomright botright))
  273.                   (with-port wptr
  274.                     (setq pict-hand (#_OpenPicture picFrame))))
  275.                 (unless (%null-ptr-p pict-hand)
  276.                   (setq *pict-output-GrafProcs* GrafProcs)
  277.                   (%put-ptr grafProcs pict-hand $gpPictHand)))
  278.               (when (eq t *pict-output-GrafProcs*)
  279.                 (setq *pict-output-pb* t)
  280.                 (rset wptr :grafport.grafProcs oldGrafProcs)))
  281.             pict-hand
  282.             )))
  283.       (when (eq t *pict-output-pb*)
  284.         (if pb (FSClose pb))
  285.         (setq *pict-output-pb* nil
  286.               *pict-output-handle* nil)
  287.         (when grafProcs
  288.           (#_DisposePtr grafProcs))))))
  289.  
  290. (defun close-pict-output-file (pict-hand)
  291.   (let ((grafProcs *pict-output-GrafProcs*)
  292.         (pb *pict-output-pb*))
  293.     (unless pb
  294.       (error "No picture output file open."))
  295.     (unless (eql pict-hand (%get-ptr grafProcs $gpPictHand))
  296.       (error "~s is not the pict-hand returned from open-pict-output-file"
  297.              pict-hand))
  298.     (let ((wptr (%get-ptr grafProcs $gpWptr))
  299.           (oldGrafProcs (%get-ptr grafProcs $gpOldGrafProcs)))
  300.       (with-port wptr
  301.         (#_ClosePicture))
  302.       (rset wptr :grafport.GrafProcs oldGrafProcs)
  303.       (#_DisposePtr grafProcs)
  304.       (SetFpos pb 512)
  305.       (with-pointers ((pict pict-hand))
  306.         (FSWrite pb $PictureSize pict))
  307.       (#_KillPicture pict-hand)
  308.       (FSClose pb)
  309.       (setq *pict-output-GrafProcs* nil
  310.             *pict-output-handle* nil
  311.             *pict-output-pb* nil))))
  312.  
  313. (defmacro with-pict-output-file ((filename window topleft botright) &body body)
  314.   (let ((pict-hand (make-symbol "PICT-HAND")))
  315.     `(let ((,pict-hand (open-pict-output-file
  316.                         ,filename ,window ,topleft ,botright)))
  317.        (unwind-protect
  318.          (progn ,@body)
  319.          (close-pict-output-file ,pict-hand)))))
  320.  
  321. (defun scale-lisp-point (point factor)
  322.   (make-point (round (* (point-h point) factor))
  323.               (round (* (point-v point) factor))))
  324.  
  325. (defun display-pict-file (filename &optional (scale-factor 1) window)
  326.   (unless window
  327.     (setq window (make-instance 'palette-window :window-show nil)))
  328.   (with-pict-input-file (pict filename window)
  329.     (let* ((topleft (scale-lisp-point (rref pict :picture.picFrame.topLeft) scale-factor))
  330.            (bottomright (scale-lisp-point (rref pict :picture.picFrame.bottomRight)
  331.                                           scale-factor))
  332.            (size (subtract-points bottomright topleft)))
  333.       (set-view-size window size)
  334.       (rlet ((rect :rect :topleft topleft :bottomright bottomright))
  335.        (window-select window)
  336.         (event-dispatch)
  337.         (with-focused-view window
  338.           (#_DrawPicture pict rect))))))
  339.  
  340. (provide :picture-files)
  341.  
  342. #|
  343. ; Example of use
  344.  
  345. (defparameter *w* (make-instance 'window :view-size #@(200 200) :color-p t))
  346.  
  347. (defvar *picture-file* "ccl:picture-file.temp")
  348.  
  349. ; Draw a square with an X inside and save it to *picture-file*
  350. (defun make-it ()
  351.   (delete-file *picture-file*)
  352.   (window-select *w*)
  353.   (with-focused-view *w*
  354.     (with-pict-output-file (*picture-file* *w* #@(0 0) #@(200 200))
  355.       (#_MoveTo 50 50)
  356.       (#_LineTo 150 50)
  357.       (#_LineTo 150 150)
  358.       (#_LineTo 50 150)
  359.       (#_LineTo 50 50)
  360.       (#_LineTo 150 150)
  361.       (#_MoveTo 150 50)
  362.       (#_LineTo 50 150))
  363.     (#_EraseRect (rref (wptr *w*) :windowRecord.portrect))))
  364.  
  365. ; Draw the picture that is in *picture-file* on *w* inside the given rect.
  366. (defun draw-it (&optional (bottomright #@(200 200)) (topleft #@(0 0)))
  367.   (window-select *w*)
  368.   (with-focused-view *w*
  369.     (#_EraseRect (rref (wptr *w*) :windowRecord.portrect))
  370.     (with-pict-input-file (pict *picture-file* *w*)
  371.       ; Real code would probably want to access
  372.       ; (rref pict :picture.picFrame.topleft) & 
  373.       ; (rref pict :picture.picFrame.bottomright) here
  374.       (unless topleft (setq topleft (rref pict :picture.picFrame.topLeft)))
  375.       (unless bottomright (setq bottomright (rref pict :picture.picFrame.bottomRight)))
  376.       (rlet ((rect :rect :topleft topleft :bottomright bottomright))
  377.         (#_DrawPicture pict rect)))))
  378.  
  379. (defun do-it ()
  380.   (make-it)
  381.   (draw-it))
  382.  
  383. |#
  384.      
  385.  
  386.